home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
akcl1615.lha
/
V
/
lsp
/
setf.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1991-07-26
|
10KB
|
503 lines
Changes file for /usr/local/src/kcl/lsp/setf.lsp
Created on Thu Jul 25 23:06:53 1991
Usage \n@s[Original text\n@s|Replacement Text\n@s]
See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
for a program to merge change files. Anything not between
"\n@s[" and "\n@s]" is a simply a comment.
This file was constructed using emacs and merge.el
Enhancements Copyright (c) W. Schelter All rights reserved.
by (Bill Schelter) wfs@carl.ma.utexas.edu
****Change:(orig (30 30 c))
@s[ `(progn (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
@s| `(eval-when(compile eval load)
(si:putprop ',access-fn ',(car rest) 'setf-update-fn)
@s]
****Change:(orig (45 45 c))
@s[ `(progn (si:putprop ',access-fn ',rest 'setf-lambda)
@s| `(eval-when (compile eval load)
(si:putprop ',access-fn ',rest 'setf-lambda)
@s]
****Change:(orig (55 56 c))
@s[(defmacro define-setf-method (access-fn &rest rest)
`(progn (si:putprop ',access-fn #'(lambda ,@rest) 'setf-method)
@s|(defmacro define-setf-method (access-fn &rest rest &aux args env body)
(multiple-value-setq (args env)
(get-&environment (car rest)))
(setq body (cdr rest))
(cond (env (setq args (cons env args)))
(t (setq args (cons (gensym) args))
(push `(declare (ignore ,(car args))) body)))
`(eval-when (compile eval load)
(si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method)
@s]
****Change:(orig (68 68 c))
@s[(defun get-setf-method (form)
@s|(defun get-setf-method (form &optional env)
@s]
****Change:(orig (70 70 c))
@s[ (get-setf-method-multiple-value form)
@s| (get-setf-method-multiple-value form env)
@s]
****Change:(orig (78 78 c))
@s[(defun get-setf-method-multiple-value (form)
@s|(defun get-setf-method-multiple-value (form &optional env &aux tem)
@s]
****Change:(orig (83 83 a))
@s[ (error "Cannot get the setf-method of ~S." form))
@s| (error "Cannot get the setf-method of ~S." form))
((and env (setq tem (assoc (car form) (second env))))
(setq tem (macroexpand form env))
(if (eq form tem) (error "Cannot get setf-method for ~a" form))
(return-from get-setf-method-multiple-value
(get-setf-method-multiple-value tem env)))
@s]
****Change:(orig (85 86 c))
@s[ (apply (get (car form) 'setf-method) (cdr form)))
((get (car form) 'setf-update-fn)
@s| (apply (get (car form) 'setf-method) env (cdr form)))
((or (get (car form) 'setf-update-fn)
(setq tem (get (car form) 'si::structure-access)))
@s]
****Change:(orig (93 94 c))
@s[ `(,(get (car form) 'setf-update-fn)
,@vars ,store)
@s| (cond (tem
(setf-structure-access (car vars) (car tem)
(cdr tem) store))
(t
`(,(get (car form) 'setf-update-fn)
,@vars ,store)))
@s]
****Change:(orig (102 102 a))
@s[ (l (get (car form) 'setf-lambda))
@s| (l (get (car form) 'setf-lambda))
;; this looks bogus to me. What if l is compiled?--wfs
@s]
****Change:(orig (162 162 c))
@s[(defsetf get (s p &optional d) (v) `(si:putprop ,s ,v ,p))
@s|(defsetf get put-aux)
(defmacro put-aux (a b &rest l)
`(si::sputprop ,a ,b ,(car (last l))))
@s]
****Change:(orig (181 181 c))
@s[(define-setf-method getf (place indicator &optional default)
@s|(define-setf-method getf (&environment env place indicator &optional default)
@s]
****Change:(orig (183 183 c))
@s[ (get-setf-method place)
@s| (get-setf-method place env)
@s]
****Change:(orig (197 197 c))
@s[(define-setf-method the (type form)
@s|(define-setf-method the (&environment env type form)
@s]
****Change:(orig (199 199 c))
@s[ (get-setf-method form)
@s| (get-setf-method form env)
@s]
****Change:(orig (206 206 c))
@s[(define-setf-method apply (fn &rest rest)
@s|(define-setf-method apply (&environment env fn &rest rest)
@s]
****Change:(orig (211 211 c))
@s[ (get-setf-method (cons (cadr fn) rest))
@s| (get-setf-method (cons (cadr fn) rest) env)
@s]
****Change:(orig (219 219 c))
@s[(define-setf-method apply (fn &rest rest)
@s|(define-setf-method apply (&environment env fn &rest rest)
@s]
****Change:(orig (226 226 c))
@s[ (get-setf-method (cons (cadr fn) rest))
@s| (get-setf-method (cons (cadr fn) rest) env)
@s]
****Change:(orig (240 240 c))
@s[(define-setf-method char-bit (char name)
@s|(define-setf-method char-bit (&environment env char name)
@s]
****Change:(orig (242 242 c))
@s[ (get-setf-method char)
@s| (get-setf-method char env)
@s]
****Change:(orig (253 253 c))
@s[(define-setf-method ldb (bytespec int)
@s|(define-setf-method ldb (&environment env bytespec int)
@s]
****Change:(orig (255 255 c))
@s[ (get-setf-method int)
@s| (get-setf-method int env)
@s]
****Change:(orig (266 266 c))
@s[(define-setf-method mask-field (bytespec int)
@s|(define-setf-method mask-field (&environment env bytespec int)
@s]
****Change:(orig (268 268 c))
@s[ (get-setf-method int)
@s| (get-setf-method int env)
@s]
****Change:(orig (281 281 c))
@s[(defun setf-expand-1 (place newvalue &aux g)
@s|(defun setf-expand-1 (place newvalue env &aux g)
@s]
****Change:(orig (284 284 c))
@s[ (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue))))
@s| (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env)))
@s]
****Change:(orig (286 286 a))
@s[ (return-from setf-expand-1 `(setq ,place ,newvalue)))
@s| (return-from setf-expand-1 `(setq ,place ,newvalue)))
(when (and (consp place)
(not (or (get (car place) 'setf-lambda)
(get (car place) 'setf-update-fn))))
(multiple-value-setq (place g) (macroexpand place env))
(if g (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
@s]
****Change:(orig (289 295 c))
@s[ (when (and (symbolp (car place))
(setq g (get (car place) 'structure-access))
(get (car place) 'setf-lambda)
(not (eq (car g) 'list))
@s, `(si:structure-set ,(cadr place) ',(car g) ,(cdr g) ,newvalue)))
@s| (cond ((and (symbolp (car place))
(setq g (get (car place) 'structure-access)))
(return-from setf-expand-1
(setf-structure-access (cadr place) (car g) (cdr g) newvalue))))
@s]
****Change:(orig (297 297 c))
@s[ (get-setf-method place)
@s| (get-setf-method place env)
@s]
****Change:(orig (304 304 c))
@s[
(defun setf-expand (l)
@s|
(defun setf-structure-access (struct type index newvalue)
(case type
(list `(si:rplaca-nthcdr ,struct ,index ,newvalue))
(vector `(si:elt-set ,struct ,index ,newvalue))
(t `(si::structure-set ,struct ',type ,index ,newvalue))))
(defun setf-expand (l env)
@s]
****Change:(orig (308 309 c))
@s[ (cons (setf-expand-1 (car l) (cadr l))
(setf-expand (cddr l))))))
@s| (cons (setf-expand-1 (car l) (cadr l) env)
(setf-expand (cddr l) env)))))
@s]
****Change:(orig (313 313 c))
@s[(defmacro setf (&rest rest)
@s|
(defun setf-helper (rest env)
(setq rest (cdr rest))
@s]
****Change:(orig (316 317 c))
@s[ ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest)))
(t (cons 'progn (setf-expand rest)))))
@s| ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env))
(t (cons 'progn (setf-expand rest env)))))
@s]
****Change:(orig (318 318 a))
@s[
@s|
;(setf (macro-function 'setf) 'setf-help)
(si::fset 'setf (cons 'macro (symbol-function 'setf-helper)))
@s]
****Change:(orig (322 322 c))
@s[(defmacro psetf (&rest rest)
@s|(defmacro psetf (&environment env &rest rest)
@s]
****Change:(orig (326 326 c))
@s[ `(progn ,(setf-expand-1 (car rest) (cadr rest))
@s| `(progn ,(setf-expand-1 (car rest) (cadr rest) env)
@s]
****Change:(orig (338 338 c))
@s[ (get-setf-method (car r))
@s| (get-setf-method (car r) env)
@s]
****Change:(orig (349 349 c))
@s[(defmacro shiftf (&rest rest)
@s|(defmacro shiftf (&environment env &rest rest )
@s]
****Change:(orig (367 367 c))
@s[ (get-setf-method (car r))
@s| (get-setf-method (car r) env)
@s]
****Change:(orig (375 375 c))
@s[(defmacro rotatef (&rest rest)
@s|(defmacro rotatef (&environment env &rest rest )
@s]
****Change:(orig (388 388 c))
@s[ (list (list (car (last stores)) (car access-forms))))
,@store-forms))
@s| (list (list (car (last stores)) (car access-forms))))
,@store-forms
nil
))
@s]
****Change:(orig (390 390 c))
@s[ (get-setf-method (car r))
@s| (get-setf-method (car r) env)
@s]
****Change:(orig (412 412 c))
@s[ `(defmacro ,name (reference . ,lambda-list)
@s| `(defmacro ,name (&environment env reference . ,lambda-list)
@s]
****Change:(orig (419 419 c))
@s[ (get-setf-method reference)
@s| (get-setf-method reference env)
@s]
****Change:(orig (429 429 c))
@s[(defmacro remf (place indicator)
@s|(defmacro remf (&environment env place indicator)
@s]
****Change:(orig (431 431 c))
@s[ (get-setf-method place)
@s| (get-setf-method place env)
@s]
****Change:(orig (441 441 c))
@s[(defmacro push (item place)
@s|(defmacro push (&environment env item place)
@s]
****Change:(orig (445 445 c))
@s[ (get-setf-method place)
@s| (get-setf-method place env)
@s]
****Change:(orig (451 451 c))
@s[(defmacro pushnew (item place &rest rest)
@s|(defmacro pushnew (&environment env item place &rest rest)
(cond ((symbolp place)
(return-from pushnew `(setq ,place (adjoin ,item ,place ,@rest)))))
@s]
****Change:(orig (453 453 c))
@s[ (get-setf-method place)
@s| (get-setf-method place env)
@s]
****Change:(orig (460 460 c))
@s[ ,store-form)))
(defmacro pop (place)
@s| ,store-form)))
(defmacro pop (&environment env place)
@s]
****Change:(orig (468 468 c))
@s[ (get-setf-method place)
@s| (get-setf-method place env)
@s]